home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / back_end / mipsgen.t < prev    next >
Encoding:
Text File  |  1990-10-15  |  12.2 KB  |  330 lines
  1. (herald (back_end mipsgen)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.                                       
  27. ;;; GENERATE-HANDLER The situation is that the object is in A1 and its template 
  28. ;;; is in TP.  The  operation is in P.  We must use only the register AN.                                 
  29.  
  30. (define (hacked-get-register node)
  31.   (cond ((reg-node an) => kill))
  32.   AN)
  33.  
  34. (define (generate-handler node obj)
  35.   (let ((leaves (call-args (lambda-body ((call-arg 3) (lambda-body node)))))
  36.         (methods (cdddr (call-args (lambda-body node)))))
  37.     (cond ((null? methods)
  38.            (emit mips/jr link-reg)
  39.            (generate-move nil-reg AN))
  40.           (else
  41.       (bind ((get-register hacked-get-register))
  42.         (mark (lambda-self-var *heap-env*) A1)
  43.         (generate-jump (car leaves))
  44.         (let ((last ((call-arg 3) (lambda-body node))))
  45.           (do ((l leaves (cdr l))
  46.                (methods methods (cdr methods)))
  47.               ((null? l)
  48.                (emit-tag last)
  49.                (emit mips/jr link-reg)
  50.            (generate-move nil-reg AN)
  51.                (clear-slots))
  52.             (generate-handler-test obj (car l) 
  53.                                    (car methods) 
  54.                                    (if (null? (cdr l)) last (cadr l))))))))))
  55.  
  56. (define (generate-handler-test obj leaf method next)
  57.   (emit-tag leaf)
  58.   (let ((el-hacko (cons nil nil)))
  59.   (emit-compare jump-op/jn= (->register nil (leaf-value leaf)) P next el-hacko)
  60.     (emit-tag el-hacko))
  61.   (lambda-queue method)
  62.   (emit risc/add (handler-diff method obj) vector AN) ;entry point in vector
  63.   (emit mips/jr link-reg)
  64.   (emit-noop))
  65.  
  66.  
  67.   
  68. ;;; %undefined-effect arg = A1
  69. (define (generate-undefined-effect node)
  70.   (let ((acc (lookup-value node (leaf-value ((call-arg 1) node)))))
  71.     (generate-slink-jump slink/undefined-effect)
  72.     (generate-move acc A1)
  73.     (clear-slots)))
  74.       
  75.  
  76. ;;; %set vcell = parassign-extra
  77.  
  78. (define (generate-set node location value)
  79.   (let ((access (if (lambda-node? value)        
  80.             (access/make-closure node value)
  81.             (->register node (leaf-value value)))))
  82.     (protect-access access)
  83.     (let ((loc (lookup node (get-lvalue (leaf-value location)) nil))
  84.       (hack1 (cons nil nil))
  85.       (hack2 (cons nil nil)))
  86.     (release-access access)
  87.     (generate-move loc parassign-extra)
  88.     (generate-move access (reg-offset parassign-extra 2))
  89.     (free-register node AN)
  90.     (lock AN)
  91.     (free-register node AN-1)
  92.     (unlock AN)
  93.     (emit risc/load 'ub (reg-offset parassign-extra 0) scratch)
  94.     (emit-compare jump-op/jn= zero scratch hack1 hack2)
  95.     (emit-tag hack1)                       
  96.     (generate-slink-call slink/set)
  97.     (generate-jump hack2)
  98.     (emit-tag hack2))))
  99.  
  100.  
  101. (define (generate-remove-state-object node)
  102.   (let ((cont (car (call-args node))))
  103.     (if (and (lambda-node? cont)
  104.          (not (lambda-rest-var cont))
  105.          (variable-refs (lambda-cont-var cont)))
  106.     (mark-continuation node AN+1))))
  107.  
  108.  
  109. (define (machine-num->register x reg)
  110.   (cond ((16bit? x)
  111.      (emit risc/add (machine-num x) zero reg))
  112.     (else
  113.      (emit mips/lui (unsigned-num
  114.              (fixnum-logand #xffff (fixnum-ashr x 16))) reg)
  115.      (emit risc/or
  116.            (unsigned-num (fixnum-logand #xffff x))
  117.            reg reg))))
  118.  
  119.  
  120. (define (generate-multiply lvar l-acc r-acc t-reg)
  121.   (cond ((fixnum? lvar)
  122.      (machine-num->register lvar scratch))
  123.     (else
  124.      (emit risc/sra (machine-num 2) l-acc scratch)))
  125.   (emit mips/mult scratch r-acc)
  126.   (emit mips/mflo t-reg))
  127.  
  128. (define (generate-divide lvar l-acc r-acc t-reg)
  129.   (cond ((fixnum? lvar)
  130.      (generate-move-addressable lvar scratch)
  131.      (emit mips/div scratch r-acc))
  132.     (else
  133.      (emit mips/div l-acc r-acc)))
  134.   (emit mips/mflo scratch)
  135.   (emit risc/sll (machine-num 2) scratch t-reg))
  136.  
  137. (define (generate-remainder lvar l-acc r-acc t-reg)
  138.   (cond ((fixnum? lvar)
  139.      (generate-move-addressable lvar scratch)
  140.      (emit mips/div scratch r-acc))
  141.     (else
  142.      (emit mips/div l-acc r-acc)))
  143.   (emit mips/mfhi t-reg))
  144.  
  145. (define (generate-extend node n)
  146.   ;; don't include template
  147.   (generate-move (machine-num (fx- n CELL)) SCRATCH)
  148.   (generate-slink-call slink/make-extend)) ; delay slot
  149.     
  150.  
  151.       
  152. (define (generate-extra-args-cons len)
  153.   (generate-move (machine-num (* len CELL 2)) SCRATCH)
  154.   (generate-slink-call slink/make-extra-args))
  155.  
  156.  
  157. (define (generate-extra-arg-move n)
  158.   (generate-move (reg-offset extra-args
  159.                  (+ (* (- n *first-stack-register*) 8) 1)) n))
  160.  
  161. ;;; This stuff almost duplicates code in parassign
  162. ;;; do-trivial-lambda and indirect-lambda and do-immediate
  163.  
  164. (define (generate-extra-arg-store node arg n)
  165.   (let ((ro (reg-offset extra-args (+ (* n 8) 1))))
  166.     (cond ((lambda-node? arg)
  167.        (cond ((eq? (environment-closure (lambda-env arg)) *unit*)
  168.           (lambda-queue arg)
  169.           (generate-move (lookup node arg nil) ro))
  170.          (else
  171.           (let ((offset (environment-cic-offset (lambda-env arg))))
  172.             (cond ((fx= offset 0)
  173.                (generate-move AN ro))
  174.               (else                   
  175.                (generate-move-address (reg-offset AN offset) ro)))))))
  176.       ((not (addressable? (leaf-value arg)))
  177.        (generate-move (lookup-value node (reference-variable arg)) ro))
  178.       (else
  179.        (generate-move-addressable (leaf-value arg) ro)))))
  180.  
  181. (define (generate-two-fixnums node)
  182.   (destructure (((then else () ref1 ref2) (call-args node)))
  183.     (let ((reg1 (->register node (leaf-value ref1))))
  184.       (lock reg1)
  185.       (let ((reg2 (->register node (leaf-value ref2))))
  186.     (unlock reg1)
  187.         (cond ((target-fixnum? (leaf-value ref2))
  188.            (emit risc/and (machine-num 3) reg1 SCRATCH))
  189.           (else
  190.            (emit risc/or reg1 reg2 SCRATCH)
  191.            (emit risc/and (machine-num 3) SCRATCH SCRATCH)))
  192.         (emit-compare jump-op/jn= SCRATCH zero else then)))))
  193.  
  194. (define (generate-op-with-overflow node op) 
  195.   (destructure (((then else () ref1 ref2) (call-args node)))
  196.     (let ((reg1 (->register node (leaf-value ref1))))
  197.       (lock reg1)
  198.       (let ((reg2 (->register node (leaf-value ref2))))
  199.     (lock reg2)
  200.     (let ((target (get-register node))
  201.           (hack (cons nil nil)))
  202.       (unlock reg1)
  203.       (unlock reg2)
  204.       (xcase op
  205.     ((add)
  206.      (emit mips/addu reg2 reg1 target)
  207.      (emit risc/xor reg2 reg1 scratch)
  208.      (emit-compare jump-op/j>= scratch zero hack then)
  209.      (emit-tag hack)
  210.      (emit risc/xor reg2 target scratch)     
  211.      (emit-compare jump-op/j>= scratch zero else then))
  212.     ((subtract) 
  213.      (emit mips/subu reg2 reg1 target)
  214.      (emit risc/xor reg2 reg1 scratch)
  215.      (emit-compare jump-op/j>= scratch zero then hack)
  216.      (emit-tag hack)
  217.      (emit risc/xor reg2 target scratch)     
  218.      (emit-compare jump-op/j>= scratch zero then else))
  219.     ((multiply)
  220.      (emit risc/sra (machine-num 2) reg1 scratch)
  221.      (emit mips/mult scratch reg2)
  222.      (emit mips/mflo target)
  223.      (emit mips/mfhi scratch)
  224.      (emit risc/sra (machine-num 31) target vector)
  225.      (emit-compare jump-op/jn= scratch vector then else)))
  226.       (mark (car (lambda-variables else)) target))))))
  227.  
  228. (define (generate-foreign-call node)
  229.   (destructure (((#f foreign rep-list value-rep . args) (call-args node)))
  230.     (emit risc/store 'l sp (reg-offset nil-reg slink/saved-sp))
  231.     (emit risc/store 'l ssp (reg-offset nil-reg slink/saved-ssp))
  232.     (emit risc/store 'l crit-reg (reg-offset nil-reg slink/saved-crit))
  233.     (let* ((rep-list (map cadr (leaf-value rep-list)))
  234.        (replen (length rep-list))
  235.        (bump-bytes (+ (* (max 0 (- replen  4)) 4) 24))) ;24=base stack frame
  236.       (emit risc/sub (machine-num bump-bytes) sSP sSP)
  237.       (emit risc/store 'l link-reg (reg-offset ssp (fx- bump-bytes 4)))
  238.       (cond ((every? (lambda (x) (neq? x 'rep/double)) rep-list)
  239.          (receive (reg-args stack-args)
  240.            (if (fx<= replen 4)
  241.            (return rep-list '())
  242.            (return (nthcdr rep-list (fx- replen 4))
  243.                (reverse (sublist rep-list 0 (fx- replen 4)))))
  244.            (do ((reps stack-args (cdr reps))
  245.             (i 16 (fx+ i 4))
  246.             (in A5 (fx+ in 1)))
  247.            ((null? reps)
  248.             (do ((in (length reg-args) (fx- in 1))
  249.              (out (fx+ (length reg-args) 1) (fx- out 1))
  250.              (reps reg-args (cdr reps)))
  251.             ((null? reps))
  252.               (pointer->rep in out (car reps))
  253.               (lock out)))
  254.          (cond ((fx< in AN)
  255.             (pointer->rep in AN (car reps)))
  256.                (else
  257.             (emit risc/load 'l 
  258.               (reg-offset extra-args (+ (* (- in AN) 8) %%car))
  259.               parassign-extra)
  260.             (pointer->rep parassign-extra AN (car reps))))
  261.          (emit risc/store 'l AN (reg-offset ssp i)))))
  262.         ((or (any? (lambda (x) (neq? x 'rep/double)) rep-list)
  263.          (fx> (length rep-list) 2))
  264.          (bug "Can't deal with this mix of float reps"))
  265.         ((null? (cdr rep-list))
  266.          (asemit mips/fload `((reg-offset ,A1 ,double/low-offset) 12))
  267.          (asemit mips/fload `((reg-offset ,A1 ,double/high-offset) 13)))
  268.         (else
  269.          (asemit mips/fload `((reg-offset ,A1 ,double/low-offset) 12))
  270.          (asemit mips/fload `((reg-offset ,A1 ,double/high-offset) 13))
  271.          (asemit mips/fload `((reg-offset ,A2 ,double/low-offset) 14))
  272.          (asemit mips/fload `((reg-offset ,A2 ,double/high-offset) 15))))
  273.       (generate-move (lookup-value node (leaf-value foreign)) an)
  274.       (emit risc/load 'l (reg-offset an 6) an)
  275.       (emit mips/jalr an link-reg)
  276.       (emit mips/noop)
  277.       (generate-move zero extra-args)
  278.       (generate-move zero extra)
  279.       (do ((i a2 (fx+ i 1)))
  280.       ((fx> i an+1))
  281.     (generate-move zero i))
  282.       (emit risc/load 'l (reg-offset ssp (fx- bump-bytes 4)) link-reg)
  283.       (emit risc/add (machine-num bump-bytes) sSP sSP))
  284.     (case (leaf-value value-rep)
  285.       ((rep/undefined ignore)
  286.        (generate-move zero a1)
  287.        (generate-move zero p))       
  288.       ((rep/double)
  289.        (generate-move zero p)
  290.        (generate-move (machine-num header/double-float) AN)
  291.        (generate-move (machine-num 8) scratch)       
  292.        (generate-slink-call slink/make-extend)
  293.        (asemit mips/fstore `(1 (reg-offset ,AN ,double/high-offset))) ; $f1
  294.        (asemit mips/fstore `(0 (reg-offset ,AN ,double/low-offset)))  ; $f0
  295.        (generate-move AN A1))                         ; return consed flonum
  296.       (else
  297.        (rep->pointer P A1  (leaf-value value-rep)) ;P = register $2
  298.        (generate-move zero p))))
  299.     (emit risc/store 'l zero (reg-offset nil-reg slink/saved-ssp)))
  300.  
  301.  
  302. (define (pointer->rep from to rep)
  303.   (case rep
  304.     ((rep/pointer) (generate-move from to))
  305.     ((rep/extend) (emit risc/add (machine-num 2) from to))
  306.     ((rep/c-pointer) 
  307.      (emit risc/add (machine-num 2) from to)
  308.      (emit risc/srl (machine-num 2) to to) 
  309.      (emit risc/sll (machine-num 2) to to))
  310.     ((rep/string)
  311.      (emit risc/load 'l (reg-offset from 2) vector)
  312.      (emit risc/load 'l (reg-offset from 6) scratch)
  313.      (emit risc/add scratch vector vector)
  314.      (emit risc/add (machine-num 2) vector to))
  315.     ((rep/char)
  316.      (emit risc/srl (machine-num 8) from to))
  317.     (else
  318.      (emit risc/sra (machine-num 2) from to))))
  319.  
  320. (define (rep->pointer from to rep)
  321.   (case rep
  322.     ((rep/pointer) (generate-move from to))
  323.     ((rep/extend) (emit risc/sub (machine-num 2) from to))
  324.     ((rep/char)
  325.      (emit risc/sll (machine-num 8) from to)
  326.      (emit risc/or (machine-num header/char) to to))
  327.     (else
  328.      (emit risc/sll (machine-num 2) from to))))
  329.      
  330.